VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsSimpleDownload2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private WithEvents http1 As WinHttpRequest
Attribute http1.VB_VarHelpID = -1

Private m_objCallback As ISimpleDownload2

Private m_sURL As String

Private m_nRetry As Long, m_nMaxRetry As Long
Private m_bRequestRetry As Boolean

Private m_nFileSize As Long
Private m_nStart As Long, m_nEnd As Long, m_nPreferredSize As Long

Private m_objSubDownload() As New clsSimpleDownload2 '2-based
Private m_nThreadCount As Long, m_nThreadStarted As Long, m_nThreadCompleted As Long

Private m_lpParent As Long 'weak reference

Friend Function GetParent() As clsSimpleDownload2
Dim obj As clsSimpleDownload2
If m_lpParent <> 0 Then
 CopyMemory ByVal VarPtr(obj), m_lpParent, 4&
 Set GetParent = obj
 CopyMemory ByVal VarPtr(obj), 0&, 4&
End If
End Function

Friend Property Get RetryTimes() As Long
RetryTimes = m_nRetry
End Property

Friend Property Get MaxRetry() As Long
MaxRetry = m_nMaxRetry
End Property

Friend Property Get FileSize() As Long
FileSize = m_nFileSize
End Property

Friend Function StartDownload(ByVal URL As String, ByVal objCallback As ISimpleDownload2, Optional ByVal nThreadCount As Long, Optional ByVal nMaxRetry As Long, Optional ByVal nStart As Long, Optional ByVal nEnd As Long, Optional ByVal nPreferredSize As Long, Optional ByVal lpParent As Long) As Boolean
StopDownload
'///
URL = Trim(URL)
If URL = vbNullString Then Exit Function
Select Case LCase(Left(URL, 6))
Case "http:/"
Case "ftp://", "https:"
 Exit Function
Case Else
 URL = URL + "http://"
End Select
'///
If objCallback Is Nothing Then Exit Function
If nThreadCount < 1 Then nThreadCount = 1
If nMaxRetry < 1 Then nMaxRetry = 1
If nStart < 0 Then
 nStart = 0
 nEnd = 0
End If
If nEnd < nStart Then nEnd = 0
'///
Set m_objCallback = objCallback
m_sURL = URL
m_bRequestRetry = False
m_nRetry = 0
m_nMaxRetry = nMaxRetry
m_nStart = nStart
m_nEnd = nEnd
m_nPreferredSize = nPreferredSize
m_nThreadCount = nThreadCount
m_nThreadStarted = 0
m_nThreadCompleted = 0
If nThreadCount >= 2 Then
 ReDim m_objSubDownload(2 To nThreadCount)
End If
m_lpParent = lpParent
'///
StartDownload = StartDownloadInternal
End Function

'internal function
Friend Function StartDownloadInternal() As Boolean
Dim s As String
'///
On Error Resume Next
Err.Clear
'///
Debug.Print "StartDownloadInternal", m_nStart, m_nEnd
Set http1 = New WinHttpRequest
http1.Open "GET", m_sURL, True
If m_nStart > 0 Or m_nEnd > 0 Then
 s = "bytes=" + CStr(m_nStart) + "-"
 If m_nEnd >= m_nStart Then s = s + CStr(m_nEnd)
 http1.SetRequestHeader "Range", s
End If
'///
http1.Send
StartDownloadInternal = Err.Number = 0
End Function

Friend Sub StopDownload()
Set http1 = Nothing
Set m_objCallback = Nothing
m_bRequestRetry = False
m_nFileSize = 0
m_nStart = 0
m_nEnd = 0
m_nPreferredSize = 0
Erase m_objSubDownload
m_nThreadCount = 0
m_nThreadStarted = 0
m_nThreadCompleted = 0
m_lpParent = 0
End Sub

Private Sub http1_OnError(ByVal ErrorNumber As Long, ByVal ErrorDescription As String)
On Error Resume Next
Debug.Print "OnError", ErrorNumber, ErrorDescription
http1.Abort
'If Not DoRetry Then DoFailed
Set http1 = Nothing
m_bRequestRetry = True
End Sub

Private Sub http1_OnResponseDataAvailable(Data() As Byte)
On Error Resume Next
Dim m As Long
'///check if it's finished
If m_nThreadCount > 1 Then
 If m_nThreadCompleted >= m_nThreadCount - 1 Then
  Debug.Assert m_nEnd > 0
  If m_nStart >= m_nEnd Then
   '///finished
   http1.Abort
   Set http1 = Nothing
   Erase m_objSubDownload
   m_nThreadCount = 0
   '///
   If Not m_objCallback Is Nothing Then m_objCallback.OnResponseFinished
   Exit Sub
   '///
  End If
 End If
End If
'///
Err.Clear
m = 0
m = UBound(Data) - LBound(Data) + 1
If Err.Number Then m = 0
'///
If Not m_objCallback Is Nothing Then
 m_objCallback.OnResponseDataAvailable m_nStart, m, Data
 If http1 Is Nothing Then Exit Sub
End If
m_nStart = m_nStart + m
End Sub

Private Sub http1_OnResponseFinished()
On Error Resume Next
'///
Debug.Print "ResponseFinished"
'///
If m_lpParent <> 0 Then
 GetParent.ThreadCompleted
ElseIf m_nThreadCount <= 1 Or m_nThreadCompleted >= m_nThreadCount - 1 Then
 '///finished
 Set http1 = Nothing
 Erase m_objSubDownload
 m_nThreadCount = 0
 '///
 If Not m_objCallback Is Nothing Then m_objCallback.OnResponseFinished
End If
'///
End Sub

Private Sub http1_OnResponseStart(ByVal Status As Long, ByVal ContentType As String)
On Error Resume Next
Dim s0 As String, s As String
Dim i As Long, j As Long
Dim bErr As Boolean
'///
Select Case Status
Case 302, 200, 206, 416
Case Else
 '///failed
 Debug.Print "Response status failed:" + CStr(Status)
 http1.Abort
 '///
 'If Not DoRetry Then DoFailed
 Set http1 = Nothing
 m_bRequestRetry = True
 Exit Sub
End Select
'///check range
If m_nStart > 0 Or m_nEnd > 0 Then
 Err.Clear
 s0 = vbNullString
 s0 = http1.GetResponseHeader("Content-Range")
 If Err.Number <> 0 Or Left(s0, 6) <> "bytes " Then
  bErr = True
 Else
  s = Mid(s0, 7)
  i = InStr(1, s, "-")
  j = InStr(1, s, "/")
  If i = 0 Or j = 0 Or i > j Then
   bErr = True
  Else
   If m_nStart > 0 Then
    If m_nStart <> CLng(Val(Left(s, i - 1))) Then bErr = True
   End If
   If m_nPreferredSize > 0 Then
    If m_nPreferredSize <> CLng(Val(Mid(s, j + 1))) Then bErr = True
   End If
   If m_nEnd > 0 Then
    If m_nEnd <> CLng(Val(Mid(s, i + 1, j - i - 1))) Then bErr = True
   ElseIf Not bErr Then
    m_nEnd = CLng(Val(Mid(s, i + 1, j - i - 1)))
   End If
  End If
 End If
 If bErr Then
  Debug.Print "Content-Range failed: " + s0
  http1.Abort
  '///
  'If Not DoRetry Then DoFailed
  Set http1 = Nothing
  m_bRequestRetry = True
  Exit Sub
 End If
End If
'///check size
Err.Clear
s0 = vbNullString
s0 = http1.GetResponseHeader("Content-Length")
i = Val(s0)
If Err.Number <> 0 Then i = 0
'///
If m_lpParent <> 0 Or m_nStart > 0 Then 'ad-hoc fix
' If m_nPreferredSize > 0 And i <> m_nPreferredSize Then
'  Debug.Print "Content-Length mismatch"
'  http1.Abort
'  '///
'  If Not DoRetry Then DoFailed
'  Exit Sub
' End If
 m_nFileSize = m_nPreferredSize
 '///
 If m_lpParent <> 0 Then GetParent.ThreadStarted
Else
 m_nFileSize = i
 m_nPreferredSize = i '??
 If Not m_objCallback Is Nothing Then
  m_objCallback.OnResponseStart i
  If http1 Is Nothing Then Exit Sub
 End If
 If m_nThreadCount > 1 Then
  If i <= &H10000 Then
   Debug.Print "Content-Length unknown or too small; disable multi-thread download"
   '///
   Erase m_objSubDownload
   m_nThreadCount = 1
  Else
   '///init multi-thread download
   Debug.Print "Init multi-thread download"
   bErr = False
   For j = 2 To m_nThreadCount
    If Not m_objSubDownload(j).StartDownload(m_sURL, m_objCallback, 1, m_nMaxRetry, (i * (j - 1)) \ m_nThreadCount, (i * j) \ m_nThreadCount - 1, i, ObjPtr(Me)) Then
     bErr = True
     Exit For
    End If
   Next j
   If bErr Then
    Debug.Print "Init multi-thread download failed!"
    DisableMultiThread
   Else
    '///we shouldn't set now because if multi-thread failed and main thread is completed then bug occurs
    'm_nEnd = i \ m_nThreadCount - 1
   End If
  End If
 End If
End If
'///
End Sub

'internal function
Friend Sub ThreadStarted()
If m_nThreadCount > 1 Then
 m_nThreadStarted = m_nThreadStarted + 1
 Debug.Print "ThreadStarted: " + CStr(m_nThreadStarted) + "/" + CStr(m_nThreadCount)
 If m_nThreadStarted = m_nThreadCount - 1 Then
  'set end position of main thread
  m_nEnd = m_nFileSize \ m_nThreadCount - 1
  Debug.Assert m_nEnd > 0
 End If
End If
End Sub

'internal function
Friend Sub ThreadCompleted()
If m_nThreadCount > 1 Then
 m_nThreadCompleted = m_nThreadCompleted + 1
 Debug.Print "ThreadCompleted: " + CStr(m_nThreadCompleted) + "/" + CStr(m_nThreadCount)
 If m_nThreadCompleted >= m_nThreadCount - 1 Then
  Debug.Assert m_nEnd > 0
  If m_nStart >= m_nEnd Then
   '///finished
   On Error Resume Next
   http1.Abort
   Set http1 = Nothing
   Erase m_objSubDownload
   m_nThreadCount = 0
   '///
   If Not m_objCallback Is Nothing Then m_objCallback.OnResponseFinished
   '///
  End If
 End If
End If
End Sub

'internal function
Friend Sub DisableMultiThread()
Debug.Print "multi-thread download disabled"
'///
Erase m_objSubDownload
m_nThreadCount = 1
m_nThreadStarted = 0
m_nThreadCompleted = 0
m_nEnd = 0
End Sub

'should constantly call this function
Friend Sub RequestRetry()
Dim i As Long
'///
If m_bRequestRetry Then
 Debug.Print "RequestRetry() is running"
 If Not DoRetry Then
  DoFailed
  Exit Sub
 End If
 m_bRequestRetry = False
End If
'///
i = 2
Do While i <= m_nThreadCount
 If Not m_objSubDownload(i) Is Nothing Then
  m_objSubDownload(i).RequestRetry
 End If
 i = i + 1
Loop
'///
End Sub

Friend Sub DoFailed()
Dim obj As ISimpleDownload2
Debug.Print "Max retry times reached; exiting"
If m_lpParent <> 0 Then
 GetParent.DisableMultiThread
Else
 Set obj = m_objCallback
End If
StopDownload
'///
If Not obj Is Nothing Then obj.OnError -1, "Failed"
End Sub

Friend Function DoRetry() As Boolean
On Error Resume Next
'///
m_nRetry = m_nRetry + 1
If m_nRetry < m_nMaxRetry Then
 If Not StartDownloadInternal Then m_nRetry = m_nMaxRetry
End If
DoRetry = m_nRetry < m_nMaxRetry
'///
End Function
